home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
feel-075.lha
/
feel0.75
/
Src
/
extras0.em
< prev
next >
Wrap
Lisp/Scheme
|
1992-06-18
|
10KB
|
398 lines
;; Eulisp Module
;; Author: pab
;; File: extras0.em
;; Date: Fri Jan 10 04:17:12 1992
;;
;; Project:
;; Description:
;;
(defmodule extras0
(ccc lists list-operators others arith calls macros0 tables
(except (null) class-names)
classes
symbols
formatted-io
generics
vectors
strings
) ()
(defun not (widget) (null widget))
(export not)
(defun caar (x) (car (car x)))
(defun cadr (x) (car (cdr x)))
(defun cdar (x) (cdr (car x)))
(defun cddr (x) (cdr (cdr x)))
(export caar cadr cdar cddr)
(defun caaar (x) (car (car (car x))))
(defun caadr (x) (car (car (cdr x))))
(defun cadar (x) (car (cdr (car x))))
(defun caddr (x) (car (cdr (cdr x))))
(defun cdaar (x) (cdr (car (car x))))
(defun cdadr (x) (cdr (car (cdr x))))
(defun cddar (x) (cdr (cdr (car x))))
(defun cdddr (x) (cdr (cdr (cdr x))))
(export caaar caadr cadar caddr cdaar cdadr cddar cdddr)
(defun caaaar (x) (car (car (car (car x)))) )
(defun caaadr (x) (car (car (car (cdr x)))) )
(defun caadar (x) (car (car (cdr (car x)))) )
(defun caaddr (x) (car (car (cdr (cdr x)))) )
(defun cadaar (x) (car (cdr (car (car x)))) )
(defun cadadr (x) (car (cdr (car (cdr x)))) )
(defun caddar (x) (car (cdr (cdr (car x)))) )
(defun cadddr (x) (car (cdr (cdr (cdr x)))) )
(defun cdaaar (x) (cdr (car (car (car x)))) )
(defun cdaadr (x) (cdr (car (car (cdr x)))) )
(defun cdadar (x) (cdr (car (cdr (car x)))) )
(defun cdaddr (x) (cdr (car (cdr (cdr x)))) )
(defun cddaar (x) (cdr (cdr (car (car x)))) )
(defun cddadr (x) (cdr (cdr (car (cdr x)))) )
(defun cdddar (x) (cdr (cdr (cdr (car x)))) )
(defun cddddr (x) (cdr (cdr (cdr (cdr x)))) )
(export caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cdddar cddadr cddddr)
(defun eqcar (a b) (cond ((atom a) nil) ((eq (car a) b) t) (t nil)))
(export eqcar)
(defun mkquote (x) (list 'quote x))
(export mkquote)
(defun assq (a l)
(cond
((null l) nil)
((eq a (caar l)) (car l))
(t (assq a (cdr l)))) )
(export assq)
(defun list-ref (l n)
(if (equal n 0) (car l)
(list-ref (cdr l) (\- n 1))))
(export list-ref)
(defun \@list-ref-update\@ (l n obj)
(if (equal n 0) ((setter car) l obj)
(\@list-ref-update\@ (cdr l) (- n 1) obj)))
(defun reverse (l)
(reverse-aux l nil))
(defun reverse-aux (l so-far)
(if l (reverse-aux (cdr l)
(cons (car l) so-far))
so-far))
;; (defun reverse (l)
;; (labels ((rev1 (l n)
;; (if (null l) n
;; (rev1 (cdr l) (cons (car l) n)))))
;; (rev1 l nil)))
(export reverse)
(defun subst (a b c)
(cond
((equal c b) a)
((atom c) c)
(t
((lambda (carc cdrc)
(cond ((and (eq carc (car c)) (eq cdrc (cdr c))) c)
(t (cons carc cdrc))))
(subst a b (car c))
(subst a b (cdr c))))))
(export subst)
(defun delete (a b comp)
(cond
((null b) nil)
((comp a (car b)) (cdr b))
(t ((lambda (del)
(cond ((eq del (cdr b)) b)
(t (cons (car b) del))))
(delete a (cdr b) comp)))))
(export delete)
(defun deleteq (a b)
(cond
((null b) nil)
((eq a (car b)) (cdr b))
(t ((lambda (del)
(cond ((eq del (cdr b)) b)
(t (cons (car b) del))))
(deleteq a (cdr b))))))
(export deleteq)
;;
;; Missing bits...
;;
(defun negativep (i) (binary-lt i 0))
(export negativep)
(defun list-copy-aux (l new)
(if l (list-copy-aux (cdr l) (nconc new (cons (car l) nil)))
new))
(defun list-copy (l) (list-copy-aux l nil))
(export list-copy)
;; Conversion
;; According to the standard (nearly)
(defconstant *convert-tab* (make-table eq))
(defun converter (class)
(let ((xx (table-ref *convert-tab* class)))
(if (not (null xx))
xx
(let ((new-gen (make-converter-generic class)))
((setter converter) class new-gen)
new-gen))))
(interpret-time
(defun make-converter-generic (class)
(let ((gf (make-instance generic-function
'name (make-symbol (format nil "~a-converter" (class-name class)))
'lambda-list '(a)
'method-class method)))
(add-method gf (make-instance method
'signature (list class)
'function (lambda (x y o) o))))))
(compile-time
(defun make-converter-generic (class)
(let ((gf (make-instance generic-function
'name (make-symbol (format nil "~a-converter" (class-name class)))
'lambda-list '(a)
'method-class method)))
(add-method gf (make-instance method
'signature (list class)
'function (lambda (o) o))))))
((setter setter) converter
(lambda (class fn)
((setter table-ref) *convert-tab* class fn)))
(defun convert (x class)
((converter class) x))
(export converter convert)
;; shove in the defined methods...
;; Really so trivial that we could use lisp functions...
(add-method (converter vector)
(make-instance method
'signature (list pair)
'function generic_generic_convert\,Cons\,Vector))
(add-method (converter pair)
(make-instance method
'signature (list vector)
'function generic_generic_convert\,Vector\,Cons))
(compile-time
(add-method (converter vector)
(make-instance method
'signature (list (class-of nil))
'function
(lambda (c)
(make-vector 0))))
(add-method (converter string)
(make-instance method
'signature (list object)
'function (lambda (obj)
(format nil "~a" obj))))
(add-method (converter string)
(make-instance method
'signature (list character)
'function (lambda (obj)
(make-string 1 obj))))
)
(interpret-time
(add-method (converter vector)
(make-instance method
'signature (list (class-of nil))
'function
(lambda (a b c)
(make-vector 0))))
(add-method (converter string)
(make-instance method
'signature (list object)
'function (lambda (a b obj)
(format nil "~a" obj))))
(add-method (converter string)
(make-instance method
'signature (list character)
'function (lambda (a b obj)
(make-string 1 obj))))
)
;; Also need to add:
;; (allsorts) number from string
;; char<-->int
;; string->pair
;; Changing the habit of a lifetime
(interpret-time
(defconstant length (make-instance generic-function
'name 'length
'lambda-list '(l)
'method-class method))
(add-method length (make-instance method
'signature (list pair)
'function list-length))
(add-method length (make-instance method
'signature (list (class-of nil))
'function (lambda (a b x) 0)))
(add-method length (make-instance method
'signature (list vector)
'function vector-length))
(add-method length (make-instance method
'signature (list string)
'function string-length))
)
(compile-time
(defconstant length (make-instance generic-function
'name 'length
'lambda-list '(l)
'method-class method))
(add-method length (make-instance method
'signature (list pair)
'function list-length))
(add-method length (make-instance method
'signature (list (class-of nil))
'function (lambda (x) 0)))
(add-method length (make-instance method
'signature (list vector)
'function vector-length))
(add-method length (make-instance method
'signature (list string)
'function string-length))
)
(export length)
(defun mapcan (f l)
(if (atom l) nil
(nconc (f (car l))
(mapcan f (cdr l)))))
(defconstant generic-function-methods
(make-instance generic-function
'name 'generic-function-methods
'lambda-list '(gf)
'method-class method))
(export generic-function-methods)
;; interpret only
(defun gfm (x y gf)
(labels ((get-method (l)
(if (atom (cadr l))
(list (cadr l))
(mapcan get-method (cdr l)))))
(mapcan get-method (generic-method-table gf))))
(add-method generic-function-methods
(make-instance method
'signature (list generic-function)
'function gfm))
(defconstant find-method
(make-instance generic-function
'name 'find-method
'lambda-list '(gf sig)
'method-class method))
(defun match-sigs (sig meths)
(cond ((atom meths) ())
((equal sig (method-signature (car meths))) (car meths))
(t (match-sigs sig (cdr meths)))))
(add-method find-method
(make-instance method
'signature (list generic-function pair)
'function (lambda (x y gf sig)
(match-sigs sig (generic-function-methods gf)))))
(export find-method)
;; next version junk....
(defun make-constructor (class)
(lambda a
(initialize-instance (allocate-instance class a) a)))
(export make-constructor)
;; add make-predicate...
(defconstant make-predicate
(make-instance generic-function
'name 'make-predicate
'lambda-list '(class)
'method-class method))
;; probably portable
(add-method make-predicate
(make-instance
method
'signature (list class)
'function
(lambda (h1 h2 x)
(let ((gf (make-instance generic-function
'name (make-symbol (format nil "~a-p" (class-name x)))
'lambda-list '(obj)
'method-class method)))
(add-method gf
(make-instance method
'signature (list object)
'function (lambda (x y ob)
nil)))
(add-method gf
(make-instance method
'signature (list x)
'function (lambda (x y ob)
t)))
gf))))
(export make-predicate)
)